home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / cmlisp.emc < prev    next >
Lisp/Scheme  |  1992-04-03  |  20KB  |  668 lines
  1. #include "mp_arith.h"
  2. #include "mp_type.h"
  3.  
  4. (defmodule cmlisp (standard0 plural cmlisp-ll) ()
  5.   
  6.   (defclass mp-object ()
  7.     ((context
  8.       initarg context
  9.       reader  context)
  10.      (offset
  11.       initarg offset
  12.       reader  offset))
  13.     predicate mp-object-p)
  14.   
  15.   (defclass xec (mp-object)
  16.     ()
  17.     constructor (allocate-xec context offset)
  18.     predicate xecp)
  19.   
  20.   (defmethod generic-prin ((p xec) str)
  21.     (format str "#x(")
  22.     (mp-print (context p) (offset p) str)
  23.     (format str ")")
  24.     p)
  25.   
  26.   (defmethod generic-write ((p xec) str)
  27.     (format str "#x(")
  28.     (mp-print (context p) (offset p) str)
  29.     (format str ")")
  30.     p)
  31.   
  32. ; Most Actual operations on xecs are those done with the "everywhere"
  33. ; context of (on our machine) 512 elements. As we know we are always
  34. ; using this context we work with the offsets and the EverWhere-Context
  35. ; which is abbreviated to EW-Ctxt. We define some operations and contexts
  36. ; which work solely in this context and they have the EWC prefix. EveryWhere
  37. ; is used to distinguish "everywhere" xappings {->obj} from orfinary xappings
  38.  
  39.   (setq EW-Ctxt (mp-make-context 512))
  40.   ((setter the-context) EW-Ctxt)
  41.  
  42.   (defun Init-EveryWhere (MasPar-Config)
  43.     (let ((Ids (mp-make-plural EW-Ctxt)))
  44.       (labels ((recurse (n) 
  45.              (mp-set EW-Ctxt Ids n n)
  46.              (if (zerop n) Ids (recurse (- n 1)))))
  47.         (recurse MasPar-Config))))
  48.   
  49.   (setq EW-Ofst (Init-EveryWhere 512))
  50.  
  51.   (setq WhereNext 510)
  52.   (setq XectorLim 1)
  53.  
  54.   (setq EW-Nil (mp-bang EW-Ctxt ()))
  55.   (setq EW-Zero (mp-bang EW-Ctxt 0))
  56.   (setq EW-Unit (mp-bang EW-Ctxt 1))
  57.   (setq EW-Wild (mp-bang EW-Ctxt 9999))
  58.   
  59.   (defun EW-Times (a b)
  60.     (mp-bin-op EW-Ctxt a b MP_TIMES))
  61.   
  62.   (defun EW-Minus (a b)
  63.     (mp-bin-op EW-Ctxt a b MP_DIFFERENCE))
  64.   
  65.   (defun EW-Plus (a b)
  66.     (mp-bin-op EW-Ctxt a b MP_PLUS))
  67.   
  68.   (defun EW-Scan-Plus (a)
  69.     (mp-scan-op EW-Ctxt a MP_PLUS))
  70.  
  71.   (setq WA-Ofst (EW-Plus EW-Ofst EW-Zero))
  72.   (setq EW-Shift (mp-set EW-Ctxt (EW-Plus EW-Ofst EW-Unit) 511 0))
  73.  
  74. ; Below I have adopted the convention that any capitalised variable name 
  75. ; holds te offset of a xec with the EveryWhere context
  76.  
  77. ; where takes an object and returns a processor id (of sorts) which is
  78. ; used as the rendezvous address
  79.  
  80.   (defcondition no-more-PEs ())
  81.  
  82.   (defun where (o)
  83.     (let ((Here (EW-Plus EW-Zero EW-Zero)))
  84.       (cond 
  85.        ((and (eq (class-of o) integer) (< o WhereNext))
  86.     (if (> o XectorLim) (setq XectorLim o) o))
  87.        ((mp-if EW-Ctxt (mp-eq EW-Ctxt WA-Ofst (mp-bang EW-Ctxt o)))
  88.     (progn
  89.       (mp-assign EW-Ctxt Here EW-Ofst)
  90.       (mp-fi EW-Ctxt)
  91.       (mp-ref EW-Ctxt (mp-scan-op EW-Ctxt Here MP_MAX) 511)))
  92.        ((> WhereNext XectorLim)
  93.     (progn 
  94.       (mp-fi EW-Ctxt)
  95.       (mp-set EW-Ctxt WA-Ofst WhereNext o)
  96.       (setq WhereNext (- WhereNext 1))
  97.       (+ WhereNext 1)))
  98.        (t (progn (mp-fi EW-Ctxt)
  99.          (error "Exhausted PE Locations" no-more-PEs))))))
  100.  
  101.   (defun Intersect (Xecs)
  102.     (labels ((n-and (list-of-xecs)
  103.              (if (= (list-length list-of-xecs) 1) (car list-of-xecs)
  104.          (mp-and EW-Ctxt (car list-of-xecs)
  105.              (n-and (cdr list-of-xecs)))))
  106.          (n-car (list-of-xecs)
  107.            (if (cdr list-of-xecs) (n-car (cdr list-of-xecs)) ())
  108.            (mp-assign EW-Ctxt (car list-of-xecs)
  109.               (mp-car EW-Ctxt (car list-of-xecs)))))
  110.        (mp-if EW-Ctxt (if Xecs (n-and Xecs) EW-Ofst))
  111.        (if Xecs (n-car Xecs) ())
  112.        (EW-Plus EW-Unit EW-Zero)))
  113.   
  114.   (setq it eq)
  115.  
  116.   (defun reunite (Result Units)
  117.     (mp-else EW-Ctxt)
  118.     (mp-assign EW-Ctxt Result EW-Nil)
  119.     (mp-assign EW-Ctxt Units EW-Zero)
  120.     (mp-fi EW-Ctxt)
  121.     (let ((is-a (what-is-it Units))
  122.       (Enum (EW-Scan-Plus Units)))
  123.       (if (it is-a everywhere) (allocate-everywhere Result
  124.                             (mp-ref EW-Ctxt Result 0))
  125.     (let* ((new-ctx (mp-make-context (mp-ref EW-Ctxt Enum 511)))
  126.            (To (EW-Plus (mp-bang EW-Ctxt (cm-start new-ctx))
  127.                 (EW-Plus (EW-Minus Enum EW-Unit)
  128.                      (EW-Times EW-Wild
  129.                            (EW-Minus Units EW-Unit))))))
  130.       ((if (it is-a xector) allocate-xector allocate-xapping) new-ctx 
  131.        (mp-car new-ctx (cm-put EW-Ctxt EW-Ofst To new-ctx))
  132.        (mp-car new-ctx (cm-put EW-Ctxt Result To new-ctx)))))))
  133.  
  134.   (defun what-is-it (Units)
  135.     (cond
  136.      ((eq (mp-ref EW-Ctxt Units 511) 1) everywhere)
  137.      ((zerop (mp-ref EW-Ctxt Units 0))  xapping)
  138.      (t (let ((Sftd-Units 
  139.            (mp-set EW-Ctxt 
  140.                (mp-car EW-Ctxt (cm-put EW-Ctxt Units EW-Shift EW-Ctxt))
  141.                0 1)))
  142.       (mp-if EW-Ctxt (mp-eq EW-Ctxt Units EW-Unit))
  143.       (mp-if EW-Ctxt (mp-eq EW-Ctxt Sftd-Units EW-Unit))
  144.       (let ((is-a-xapping (mp-else EW-Ctxt)))
  145.         (mp-fi EW-Ctxt)
  146.         (mp-fi EW-Ctxt)
  147.         (if is-a-xapping xapping xector))))))
  148.  
  149. ; Xappings, the bit the user actually sees and works with and protects
  150. ; him from the nasty underlying operations
  151.  
  152.   (defclass xapping ()
  153.     ((context
  154.       initarg context
  155.       reader context)
  156.      (domain
  157.       initarg domain
  158.       reader domain)
  159.      (range
  160.       initarg range
  161.       accessor range))
  162.     predicate xappingp
  163.     constructor (allocate-xapping context domain range))
  164.  
  165.   (defun xapping-domain-ref (x i)
  166.     (mp-ref EW-Ctxt WA-Ofst (mp-ref (context x) (domain x) i)))
  167.  
  168.   (defun xapping-range-ref (x i)
  169.     (mp-ref (context x) (range x) i))
  170.  
  171.   (defun xapping-length (x)
  172.     (mp-length (context x)))
  173.  
  174.   (defmethod generic-write ((x xapping) str)
  175.     (let ((len (- (xapping-length x) 1)))
  176.       (labels ((print-pairs (i)
  177.              (format str "~a->~a" (xapping-domain-ref x i)
  178.              (xapping-range-ref x i))
  179.          (if (< i len) (progn (format str " ")
  180.                       (print-pairs (+ i 1))) ())))
  181.     (format str "#X(")
  182.     (print-pairs 0)
  183.     (format str ")"))))
  184.  
  185.   (defmethod generic-prin ((x xapping) str)
  186.     (let ((len (- (xapping-length x) 1)))
  187.       (labels ((print-pairs (i)
  188.              (format str "~a->~a" (xapping-domain-ref x i)
  189.              (xapping-range-ref x i))
  190.          (if (< i len) (progn (format str " ")
  191.                       (print-pairs (+ i 1))) ())))
  192.     (format str "#X(")
  193.     (print-pairs 0)
  194.     (format str ")"))))
  195.  
  196.   (defun list-to-xapping (pair-list)
  197.     (if (not (evenp (list-length pair-list)))
  198.       (error "Not an even number of elements" illegal-arg)
  199.       (let* ((new-context (mp-make-context (/ (list-length pair-list) 2)))
  200.          (new-domain  (mp-make-plural new-context))
  201.          (new-range   (mp-make-plural new-context)))
  202.     (labels ((recurse (pair-list i)
  203.            (if (cddr pair-list) (recurse (cddr pair-list) (+ i 1)) ())
  204.            (mp-set new-context new-domain i (where (car pair-list)))
  205.            (mp-set new-context new-range i (cadr pair-list))))
  206.         (progn 
  207.           (recurse pair-list 0)
  208.           (allocate-xapping new-context new-domain new-range))))))
  209.         
  210.   (defclass xector (xapping)
  211.     ()
  212.     predicate xectorp
  213.     constructor (allocate-xector context domain range))
  214.   
  215.   (defmethod generic-prin ((x xector) str)
  216.     (format str "#X[")
  217.     (mp-print (context x) (range x))
  218.     (format str "]")
  219.     x)
  220.  
  221.   (defmethod generic-write ((x xector) str)
  222.     (format str "#X[")
  223.     (mp-print (context x) (range x))
  224.     (format str "]")
  225.     x)
  226.  
  227.   (defcondition xector-too-big ())
  228.   
  229.   (defun list-to-xector (list)
  230.     (if (>= (list-length list) WhereNext)
  231.       (error "Xector to big to accomodate" xector-too-big)
  232.       (let* ((new-context (mp-make-context (list-length list)))
  233.          (new-domain  (mp-make-plural  new-context))
  234.          (new-range   (mp-make-plural  new-context)))
  235.     (if (< (list-length list) XectorLim) ()
  236.       (setq XectorLim (list-length list)))
  237.     (labels ((recurse (list i)
  238.            (if (cdr list) (recurse (cdr list) (+ i 1)) ())
  239.            (mp-set new-context new-domain i i)
  240.            (mp-set new-context new-range  i (car list))))
  241.       (progn 
  242.         (recurse list 0)
  243.         (allocate-xector new-context new-domain new-range))))))
  244.  
  245.   (defclass everywhere (xapping)
  246.     ()
  247.     predicate everywherep
  248.     constructor (allocate-everywhere domain range))
  249.  
  250.   (defmethod generic-prin ((x everywhere) str)
  251.     (format str "#X( ->~a)" (range x))
  252.     x)
  253.  
  254.   (defmethod generic-write ((x everywhere) str)
  255.     (format str "#X( ->~a)" (range x))
  256.     x)
  257.  
  258.   (defun rendezvous (x)
  259.     (if (everywherep x) (domain x)
  260.       (cm-put (context x) (range x) (domain x) EW-Ctxt)))
  261.  
  262.   (defun what-pe (x i)
  263.     (let ((EW-Pes (cm-put (context x) EW-Ofst (domain x) EW-Ctxt))
  264.       (EW-Pe (EW-Plus EW-Zero EW-Zero)))
  265.       (mp-if EW-Ctxt EW-Pes)
  266.       (mp-assign EW-Ctxt EW-Pes (mp-car EW-Ctxt EW-Pes))
  267.       (if (mp-if EW-Ctxt (mp-eq EW-Ctxt WA-Ofst (mp-bang EW-Ctxt i)))
  268.     (progn
  269.       (mp-assign EW-Ctxt EW-Pe EW-Pes)
  270.       (mp-fi EW-Ctxt)
  271.       (mp-fi EW-Ctxt)
  272.       (mp-ref EW-Ctxt (mp-scan-op EW-Ctxt EW-Pe MP_MAX) 511))
  273.     (progn
  274.       (mp-fi EW-Ctxt)
  275.       (mp-fi EW-Ctxt)
  276.       ()))))
  277.  
  278.   (defcondition out-of-range ())
  279.   (defcondition illegal-arg  ())
  280.  
  281.   (defun xref (x i)
  282.     (if (xappingp x) (let ((EW-I (what-pe x i)))
  283.                (if EW-I (mp-ref EW-Ctxt (range x) EW-I)
  284.              (error "Index not in range" out-of-range)))
  285.       (error "Arg 1 not a xapping" illegal-arg)))
  286.  
  287.   (defun xset (o x i)
  288.     (if (xappingp x) (let ((EW-I (what-pe x i)))
  289.                (if EW-I (progn (mp-set EW-Ctxt (range x) EW-I o) x)
  290.              (error "Index not in range" out-of-range)))
  291.       (error "Arg 2 not a xapping" illegal-arg)))
  292.  
  293.   (defun xmod (v x i)
  294.     (if (xappingp x) (let ((EW-Index (where i))
  295.               (EW-Range (rendezvous x)))
  296.               (mp-set EW-Ctxt EW-Range EW-Index (list v))
  297.               (mp-if EW-Ctxt EW-Range)
  298.               (mp-assign EW-Ctxt EW-Range (mp-car EW-Ctxt EW-Range))
  299.               (reunite EW-Range (EW-Plus EW-Unit EW-Zero)))
  300.       (error "Arg 2 not a xapping" illegal-arg)))
  301.  
  302. ; Primitives
  303. ; ==========
  304.  
  305.   (setq pfun-table (make-table))
  306.  
  307.   (defun add-pfun (name)
  308.      ((setter table-ref) pfun-table name 
  309.       (cons (last-function-name) (last-function-arglist))))
  310.  
  311.   (setq psetter-table (make-table))
  312.   
  313.   (defun add-psetter (name) 
  314.     ((setter table-ref) psetter-table name 
  315.      (cons (last-function-name))))
  316.  
  317.   (p-1-fn mp-un-op MP_NEGATE)
  318.   (add-pfun 'negate)
  319.   (p-2-fn mp-eq ())
  320.   (add-pfun 'eq)
  321.   (p-2-fn mp-cons ())
  322.   (add-pfun 'cons)
  323.   (p-1-fn mp-car ())
  324.   (add-pfun 'car)
  325.   (p-1-fn mp-cdr ())
  326.   (add-pfun 'cdr)
  327.   (p-1-fn mp-make-vector ())
  328.   (add-pfun 'make-vector)
  329.   (p-1-fn mp-vector-length ())
  330.   (add-pfun 'vector-length)
  331.   (p-2-fn mp-vector-ref ())
  332.   (add-pfun 'vector-ref)
  333.   (p-1-fn mp-test MP_CONS)
  334.   (add-pfun (quote consp))
  335.   (p-1-fn mp-test #x7fff)
  336.   (add-pfun (quote null))
  337.   (p-1-fn mp-test INTEGER)
  338.   (add-pfun (quote intp))
  339.   (p-1-fn mp-test MP_FLOAT)
  340.   (add-pfun (quote floatp))
  341.   (p-1-fn mp-test MP_VECTOR)
  342.   (add-pfun (quote vectorp))
  343.   (p-2-fn mp-bin-op MP_PLUS)
  344.   (add-pfun (quote binary-plus))
  345.   (p-2-fn mp-bin-op MP_PLUS)
  346.   (add-pfun (quote +))
  347.   (p-2-fn mp-bin-op MP_DIFFERENCE)
  348.   (add-pfun (quote binary-difference))
  349.   (p-2-fn mp-bin-op MP_DIFFERENCE)
  350.   (add-pfun (quote -))
  351.   (p-2-fn mp-bin-op MP_TIMES)
  352.   (add-pfun (quote binary-times))
  353.   (p-2-fn mp-bin-op MP_TIMES)
  354.   (add-pfun (quote *))
  355.   (p-2-fn mp-bin-op MP_DIVIDE)
  356.   (add-pfun (quote binary-divide))
  357.   (p-2-fn mp-bin-op MP_DIVIDE)
  358.   (add-pfun (quote /))
  359.   (p-2-fn mp-rel-op MP_GT)
  360.   (add-pfun (quote binary-gt))
  361.   (p-2-fn mp-rel-op MP_GT)
  362.   (add-pfun (quote >))
  363.   (p-2-fn mp-rel-op MP_LT)
  364.   (add-pfun (quote binary-lt))
  365.   (p-2-fn mp-rel-op MP_LT)
  366.   (add-pfun (quote <))
  367.   (p-2-fn mp-bin-op MP_REMAINDER)
  368.   (add-pfun (quote remainder))
  369.   (p-2-fn mp-and ())
  370.   (add-pfun (quote and))
  371.   (p-2-fn mp-or ())
  372.   (add-pfun (quote or))
  373.  
  374.   (p-3-fn mp-vector-set ())
  375.   (add-psetter (quote vector-ref))
  376.   (p-2-fn mp-rplaca ())
  377.   (add-psetter (quote car))
  378.   (p-2-fn mp-rplacd ())
  379.   (add-psetter (quote cdr))
  380.  
  381. ; There are a few lisp functions who work in parallel - this is a hack!
  382.  
  383.   ((setter table-ref) pfun-table 'progn (cons 'progn ()))
  384.  
  385. ; Alpha
  386. ; =====
  387.  
  388.   (defun rewire (form)
  389.     (cond 
  390.      ((consp form)
  391.       (cond
  392.        ((eq (car form) 'quote) (rewire (cdr form)))
  393.        ((eq (car form) (car function-name)) (cons (cadr function-name)
  394.                           (rewire (cdr form))))
  395.        ((eq (car form) 'bullet) (cadr form))
  396.        ((eq (car form) 'setter) (table-ref psetter-table (cadr form)))
  397.        ((eq (car form) 'if) (alpha-if (cadr form) (caddr form) (cadddr form)))
  398.        (t (cons (if (car form) (rewire (car form)) EW-Nil)
  399.         (rewire (cdr form))))))
  400.      ((numberp form) (mp-bang EW-Ctxt form))
  401.      (form (if (memq form arg-list) (list 'mp-bang 'EW-Ctxt form)
  402.          (let ((alpha-fun (table-ref pfun-table form)))
  403.            (if alpha-fun (car alpha-fun) (list 'mp-bang 'EW-Ctxt form)))))
  404.      (t ())))
  405.  
  406.   (defun alpha-if (bool then else)
  407.     (list 'let '((if-result (mp-make-plural EW-Ctxt)))
  408.       (list 'progn
  409.         (list 'if (list 'mp-if 'EW-Ctxt (rewire bool))
  410.               (list 'mp-assign 'EW-Ctxt 'if-result (rewire then)) ())
  411.         (list 'if (list 'mp-else 'EW-Ctxt)
  412.               (list 'mp-assign 'EW-Ctxt 'if-result (rewire else)) ())
  413.         '(mp-fi EW-Ctxt)
  414.         'if-result)))
  415.  
  416.   (defun bulletify (name)
  417.     (list 'bullet name))
  418.  
  419.   (defun Bind-args (args)
  420.     (labels ((make-binding (arg-name)
  421.            (list arg-name (list 'rendezvous arg-name)))
  422.          (recurse (list-of-args)
  423.            (if list-of-args (cons (make-binding (car list-of-args))
  424.                       (recurse (cdr list-of-args))) ())))
  425.       (append (recurse args)
  426.           (list (list 'Units (list 'Intersect 
  427.                        (cons 'list args)))))))
  428.  
  429.   (defun find-xappings (form)
  430.     (if (consp form) 
  431.       (if (eq (car form) 'bullet) 
  432.     (if ((setter table-ref) xapping-table (cadr form) t) ()
  433.       (setq xapping-list (cons (cadr form) xapping-list)))
  434.     (progn (find-xappings (car form))
  435.            (find-xappings (cdr form))))
  436.       xapping-list))
  437.  
  438. ; (alpha if) is too compilacate and has to be created as a special case
  439.  
  440.   (defmacro alpha (form)
  441.     (setq xapping-table (make-table))
  442.     (setq xapping-list ())
  443.     (setq arg-list ())
  444.     (setq function-name '(none))
  445.     (if (and (consp form) (not (eq (car form) 'setter)))
  446.       (cond 
  447.        ((eq (car form) `lambda)
  448.     (let ((args (cadr form)) (body (caddr form)))
  449.       (setq arg-list args)
  450.       `(lambda ,args
  451.          (let* ,(Bind-args (find-xappings body))
  452.            (reunite ,(rewire body) Units)))))
  453.        ((eq (car form) `defun)
  454.     (let ((args (caddr form)) (body (caddr (cdr form))))
  455.       (setq function-name (list (cadr form) (gensym)))
  456.       ((setter table-ref) pfun-table (car function-name)
  457.        (cons (cadr function-name) (caddr form)))
  458.       `(defun ,(cadr function-name) ,args
  459.          ,(rewire body))))
  460.     (t 
  461.      `((lambda ()
  462.          (let* ,(Bind-args (find-xappings form))
  463.            (reunite ,(rewire form) Units))))))
  464.       (let ((pfun (if (consp form) (table-ref psetter-table (cadr form))
  465.             (table-ref pfun-table form))))
  466.     (if pfun (let ((args (cdr pfun)))
  467.            `(lambda ,args
  468.               (let* ,(Bind-args args)
  469.             (reunite ,(rewire (cons form (mapcar bulletify args)))
  470.                  Units))))
  471.       (allocate-everywhere (mp-bang EW-Ctxt form) form)))))
  472.  
  473. ; Beta
  474. ; ====
  475.  
  476.  
  477.   (defun Build-map (index)
  478.     (let ((Map (mp-make-plural EW-Ctxt))
  479.       (len (- (mp-length (context index)) 1)))
  480.       (labels ((recurse (i)
  481.          (if (< i len) (recurse (+ i 1)) ())
  482.          (mp-if EW-Ctxt 
  483.             (mp-eq EW-Ctxt EW-Ofst
  484.                    (mp-bang EW-Ctxt 
  485.                     (where (xapping-range-ref index i)))))
  486.          (mp-assign EW-Ctxt Map
  487.                 (mp-cons EW-Ctxt 
  488.                      (mp-bang EW-Ctxt i) Map))
  489.          (mp-fi EW-Ctxt)))
  490.         (recurse 0)
  491.     Map)))
  492.  
  493.   (defun list-tail (l) (list-ref l (- (list-length l) 1)))
  494.  
  495.   (defun b-rewire (form)
  496.     (cond 
  497.      ((consp form)
  498.       (cond
  499.        ((eq (car form) 'quote) (b-rewire (cdr form)))
  500.        ((eq (car form) 'bullet) (cadr form))
  501.        (t (cons (if (car form) (b-rewire (car form)) EW-Nil)
  502.         (b-rewire (cdr form))))))
  503.      ((numberp form) (mp-bang EW-Ctxt form))
  504.      (form (if (memq form arg-list) form
  505.          (let ((alpha-fun (table-ref pfun-table form)))
  506.            (if alpha-fun (car alpha-fun) (list 'mp-bang 'EW-Ctxt form)))))
  507.      (t ())))
  508.  
  509.   (setq Botch (mp-bang EW-Ctxt 'botch))
  510.  
  511.   (defun p-default-combinator (a b) Botch)
  512.  
  513.   (defun beta-internal (Range Map with)
  514.     (mp-if EW-Ctxt Range)
  515.     (mp-assign EW-Ctxt Range (mp-car EW-Ctxt Range))
  516.     (mp-fi EW-Ctxt)
  517.     (let ((Moved (mp-move EW-Ctxt Range EW-Ctxt Map))
  518.       (Result (mp-make-plural EW-Ctxt))
  519.       (Units (EW-Plus EW-Zero EW-Zero)))
  520.       (mp-if EW-Ctxt Moved)
  521.       (mp-assign EW-Ctxt Units EW-Unit)
  522.       (labels ((recurse (List CdrList)
  523.          (if (mp-if EW-Ctxt CdrList) 
  524.            (mp-assign EW-Ctxt Result
  525.                   (with (mp-car EW-Ctxt List)
  526.                     (recurse CdrList 
  527.                          (mp-cdr EW-Ctxt CdrList)))) ())
  528.          (mp-else EW-Ctxt)
  529.          (mp-assign EW-Ctxt Result (mp-car EW-Ctxt List))
  530.          (mp-fi EW-Ctxt)
  531.          Result))
  532.      (reunite (recurse Moved (mp-cdr EW-Ctxt Moved)) Units))))
  533.  
  534. ; Modification to mp-move - plural has to be pre-allocated !
  535.  
  536.   (defun beta-internal (Range Map with)
  537.     (mp-if EW-Ctxt Range)
  538.     (mp-assign EW-Ctxt Range (mp-car EW-Ctxt Range))
  539.     (mp-fi EW-Ctxt)
  540.     (let ((Moved (mp-make-plural EW-Ctxt))
  541.       (Result (mp-make-plural EW-Ctxt))
  542.       (Units (EW-Plus EW-Zero EW-Zero)))
  543.       (mp-move EW-Ctxt Range EW-Ctxt Map Moved)
  544.       (mp-if EW-Ctxt Moved)
  545.       (mp-assign EW-Ctxt Units EW-Unit)
  546.       (labels ((recurse (List CdrList)
  547.          (if (mp-if EW-Ctxt CdrList) 
  548.            (mp-assign EW-Ctxt Result
  549.                   (with (mp-car EW-Ctxt List)
  550.                     (recurse CdrList 
  551.                          (mp-cdr EW-Ctxt CdrList)))) ())
  552.          (mp-else EW-Ctxt)
  553.          (mp-assign EW-Ctxt Result (mp-car EW-Ctxt List))
  554.          (mp-fi EW-Ctxt)
  555.          Result))
  556.      (reunite (recurse Moved (mp-cdr EW-Ctxt Moved)) Units))))
  557.  
  558.  
  559.   (defun s-default-combinator (a b) 'botch)
  560.  
  561.   (defun reduce (xapp with)
  562.     (let ((len (- (mp-length (context xapp)) 1))
  563.       (ctxt (context xapp))
  564.       (ofst (range xapp)))
  565.       (labels ((recurse (i)
  566.         (if (= i len) (mp-ref ctxt ofst i)
  567.           (with (mp-ref ctxt ofst i) (recurse (+ i 1))))))
  568.     (recurse 0))))
  569.  
  570.   (defmacro beta args
  571.     (let* ((s-form (if (= (list-length args) 0) s-default-combinator
  572.              (car args)))
  573.        (p-form (if (= (list-length args) 0) p-default-combinator
  574.              (progn
  575.                (setq xapping-table (make-table))
  576.                (setq xapping-list ())
  577.                (setq arg-list ())
  578.                (if (consp (car args))
  579.                (let ((args (cadar args)) (body (caddar args)))
  580.                  (setq arg-list args)
  581.                  (list 'lambda args (b-rewire body)))
  582.              (car (table-ref pfun-table (car args))))))))
  583.       `(lambda args
  584.      (let ((s-with ,s-form)
  585.            (p-with ,p-form))
  586.        (if (cdr args)
  587.          (beta-internal (rendezvous (car args))
  588.                 (Build-map (cadr args)) p-with)
  589.          (reduce (car args) s-with))))))
  590.  
  591.   
  592. )
  593.  
  594.  
  595. (defmacro compile (form)
  596.   (if (consp form)
  597.     (if (eq (car form) 'alpha) (macroexpand `,form)
  598.       (cons (compile (car form)) (compile (cdr form))))
  599.     form))
  600.  
  601. ;; if 
  602.  
  603. (alpha (if (< (bullet xap1) 5) (bullet xap1) (- 5 (bullet xap1))))
  604.  
  605.    (let ((if-result (mp-make-plural EW-Ctxt)))
  606.      (progn
  607.        (if (mp-if EW-Ctxt 
  608.  
  609.  
  610. (setq simon (list-to-xapping '(cap 12 perihelion 3 BUCS 3)))
  611. (setq don (list-to-xapping '(micro-automation 12 perihelion 30)))
  612. (setq duncan (list-to-xapping '(IBM 12 perihelion 24)))
  613. (setq bob (list-to-xapping '(micro-automation 18 Melbourne-Uni 3 BUCS 4)))
  614.  
  615.  
  616.  
  617. (alpha-if '(< (bullet simon) (bullet don)) '(cons (bullet simon) (bullet don))
  618.       '(cons (bullet don) (bullet simon)))
  619.  
  620.     
  621. (macroexpand (alpha (if (< (bullet simon) (bullet don))
  622.             (cons (bullet simon) (bullet don))
  623.             (cons (bullet don) (bullet simon)))))
  624.  
  625. (macroexpand (p-if ((alpha <) don simon) ((alpha cons) don simon) ((alpha cons) simon don)))
  626.  
  627.   (defmacro p-if (bool then else)
  628.     (setq xapping-table (make-table))
  629.     (setq xapping-list ())
  630.     (setq arg-list ())
  631.     `(let* ((bool-value (rendezvous ,bool))
  632.         (bool (let ((tmp (mp-assign EW-Ctxt 
  633.                     (mp-make-plural EW-Ctxt) bool-value)))
  634.             (mp-if EW-Ctxt bool)
  635.             (mp-assign EW-Ctxt bool (mp-car EW-Ctxt bool-value))
  636.             (mp-fi EW-Ctxt)))
  637.         (then (if (mp-if EW-Ctxt bool) (rendezvous ,then) EW-Nil))
  638.         (else (if (mp-else EW-Ctxt) (rendezvous ,else) EW-Nil))
  639.         (Units (Intersect (list bool then else))))
  640.        (reunite (let ((if-result (mp-make-plural EW-Ctxt)))
  641.           (mp-if EW-Ctxt bool) 
  642.           (mp-assign EW-Ctxt if-result then)
  643.           (mp-else EW-Ctxt)
  644.           (mp-assign EW-Ctxt if-result else)) Units)))
  645.     
  646.  
  647.                
  648. (defprim p-list-length (p-list)
  649.   (if p-list (+ (p-list-length (cdr p-list)) 1)
  650.     0))
  651.  
  652. (defun p-list-length (p-list)
  653.   (if (mp-if EW-Ctxt p-list) 
  654.     ((lambda (a b) (mp-bin-op EW-Ctxt a b 610))
  655.      (p-list-length ((lambda (a) (mp-cdr EW-Ctxt a)) p-list))
  656.      (mp-bang EW-Ctxt 1))))
  657.  
  658.  
  659. ; This is very strange I mean list-length is now parallel so it has
  660. ; to be bulleted - or is it?
  661.  
  662.  
  663.  
  664.  
  665.  
  666.  
  667.  
  668.